home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b3fpr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  4.7 KB  |  202 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b3fpr.c,v 1.4 85/08/22 16:58:15 timo Exp $
  5. */
  6.  
  7. /* B formula/predicate invocation */
  8. #include "b.h"
  9. #include "b0fea.h"
  10. #include "b1obj.h"
  11. #include "b3err.h"
  12. #include "b3sem.h"
  13. #include "b3sou.h"
  14.  
  15. #define Other 0
  16. #define Nume 1
  17.  
  18. #define In 1
  19. #define Not_in 2
  20. #ifdef EXT_COMMAND
  21. #define Char_ready 3
  22. #endif
  23.  
  24. /*
  25.  * Table defining all predefined functions (but not propositions).
  26.  */
  27.  
  28. #ifdef EXT_COMMAND
  29.  
  30. extern value e_getchar();
  31. extern value e_screensize();
  32. extern outcome e_ch_ready();
  33.  
  34. #endif EXT_COMMAND
  35.  
  36. struct funtab {
  37.     string f_name; literal f_adic, f_kind;
  38.     value    (*f_fun)();
  39.     bool f_extended;
  40. } funtab[] = {
  41.     {"~",  Mon, Nume, approximate},
  42.     {"+",  Mon, Nume, copy},
  43.     {"+",  Dya, Nume, sum},
  44.     {"-",  Mon, Nume, negated},
  45.     {"-",  Dya, Nume, diff},
  46.     {"*/", Mon, Nume, numerator},
  47.     {"/*", Mon, Nume, denominator},
  48.  
  49.     {"*",  Dya, Nume, prod},
  50.     {"/",  Dya, Nume, quot},
  51.     {"**", Dya, Nume, power},
  52.  
  53.     {"^",  Dya, Other, concat},
  54.     {"^^", Dya, Other, repeat},
  55.     {"<<", Dya, Other, adjleft},
  56.     {"><", Dya, Other, centre},
  57.     {">>", Dya, Other, adjright},
  58.  
  59.     {"#",  Mon, Other, size},
  60.     {"#",  Dya, Other, size2},
  61.  
  62.     {"pi", Zer, Other, pi},
  63.     {"e",  Zer, Other, e},
  64.  
  65.     {"abs",    Mon, Nume, absval},
  66.     {"sign",   Mon, Nume, signum},
  67.     {"floor",  Mon, Nume, floorf},
  68.     {"ceiling",Mon, Nume, ceilf},
  69.     {"round",  Mon, Nume, round1},
  70.     {"round",  Dya, Nume, round2},
  71.     {"mod",    Dya, Nume, mod},
  72.     {"root",   Mon, Nume, root1},
  73.     {"root",   Dya, Nume, root2},
  74.  
  75.     {"sin", Mon, Nume, sin1},
  76.     {"cos", Mon, Nume, cos1},
  77.     {"tan", Mon, Nume, tan1},
  78.     {"atan",Mon, Nume, atn1},
  79.     {"atan",Dya, Nume, atn2},
  80.     {"exp", Mon, Nume, exp1},
  81.     {"log", Mon, Nume, log1},
  82.     {"log", Dya, Nume, log2},
  83.  
  84.     {"keys", Mon, Other, keys},
  85.     {"th'of",Dya, Other, th_of},
  86.     {"min",  Mon, Other, min1},
  87.     {"min",  Dya, Other, min2},
  88.     {"max",  Mon, Other, max1},
  89.     {"max",  Dya, Other, max2},
  90.  
  91. #ifdef EXT_COMMAND
  92.     /* Extended group: */
  93.  
  94.     {"get'char", Zer, Other, e_getchar, Yes},
  95.     {"screen'size", Zer, Other, e_screensize, Yes},
  96. #endif
  97.  
  98.     {"", Dya, Other, NULL} /*sentinel*/
  99. };
  100.  
  101. Visible Procedure initfpr() {
  102.     struct funtab *fp; value r, f, pname;
  103.     extern bool extcmds; /* Flag set by -E option */
  104.     for (fp= funtab; *(fp->f_name) != '\0'; ++fp) {
  105. #ifdef EXT_COMMAND
  106.         if (fp->f_extended && !extcmds) continue;
  107. #endif
  108.         /* Define function */
  109.         r= mk_text(fp->f_name);
  110.         f= mk_fun(fp->f_adic, (intlet) (fp-funtab), NilTree, Yes);
  111.         pname= permkey(r, fp->f_adic);
  112.         def_unit(pname, f);
  113.         release(f); release(r); release(pname);
  114.     }
  115.  
  116.     defprd("in", Dya, In);
  117.     defprd("not'in", Dya, Not_in);
  118. #ifdef EXT_COMMAND
  119.     if (extcmds) defprd("char'ready", Zer, Char_ready);
  120. #endif
  121. }
  122.  
  123. Hidden Procedure defprd(repr, adic, pre) string repr; literal adic; intlet pre; {
  124.     value r= mk_text(repr), p= mk_prd(adic, pre, NilTree, Yes), pname;
  125.     pname= permkey(r, adic);
  126.     def_unit(pname, p);
  127.     release(p); release(r); release(pname);
  128. }
  129.  
  130. /* returns if a given test/yield exists *without faults* */
  131. Hidden bool is_funprd(t, f, adicity, func) value t, *f; literal adicity; bool func; {
  132.     value *aa;
  133.     if (!is_unit(t, adicity, &aa)) return No;
  134.     if (still_ok) {
  135.         if (func) {
  136.             if (!Is_function(*aa)) return No;
  137.         } else {
  138.             if (!Is_predicate(*aa)) return No;
  139.         }
  140.         *f= *aa; return Yes;
  141.     } else return No;
  142. }
  143.  
  144. Visible bool is_zerfun(t, f) value t, *f; {
  145.     return is_funprd(t, f, Zer, Yes);
  146. }
  147.  
  148. Visible bool is_monfun(t, f) value t, *f; {
  149.     return is_funprd(t, f, Mon, Yes);
  150. }
  151.  
  152. Visible bool is_dyafun(t, f) value t, *f; {
  153.     return is_funprd(t, f, Dya, Yes);
  154. }
  155.  
  156. Visible bool is_zerprd(t, p) value t, *p; {
  157.     return is_funprd(t, p, Zer, No);
  158. }
  159.  
  160. Visible bool is_monprd(t, p) value t, *p; {
  161.     return is_funprd(t, p, Mon, No);
  162. }
  163.  
  164. Visible bool is_dyaprd(t, p) value t, *p; {
  165.     return is_funprd(t, p, Dya, No);
  166. }
  167.  
  168. Visible value pre_fun(nd1, pre, nd2) value nd1, nd2; intlet pre; {
  169.     struct funtab *fp= &funtab[pre]; literal adic= fp->f_adic;
  170.     if (fp->f_kind == Nume && adic != Zer) { /* check types */
  171.         if (adic == Dya && !Is_number(nd1)) {
  172.             error3(MESSMAKE(fp->f_name), Vnil,
  173.                 MESS(4500, " has a non-numeric left operand"));
  174.             return Vnil;
  175.         } else if (!Is_number(nd2)) {
  176.             error3(MESSMAKE(fp->f_name), Vnil,
  177.                 MESS(4501, " has a non-numeric right operand"));
  178.             return Vnil;
  179.         }
  180.     }
  181.     switch (adic) {
  182.         case Zer: return((*fp->f_fun)());
  183.         case Mon: return((*fp->f_fun)(nd2));
  184.         case Dya: return((*fp->f_fun)(nd1, nd2));
  185.         default: syserr(MESS(3300, "pre-defined fpr wrong"));
  186.              /*NOTREACHED*/
  187.     }
  188. }
  189.  
  190. Visible outcome pre_prop(nd1, pre, nd2) value nd1, nd2; intlet pre; {
  191.     switch (pre) {
  192.     case In: return in(nd1, nd2);
  193.     case Not_in: return !in(nd1, nd2);
  194. #ifdef EXT_COMMAND
  195.     case Char_ready: return e_ch_ready();
  196. #endif
  197.     default:
  198.         syserr(MESS(3301, "predicate not covered by proposition"));
  199.         /*NOTREACHED*/
  200.     }
  201. }
  202.